library(ggplot2)
library(magrittr)
library(tidyr)
##
## Attaching package: 'tidyr'
## The following object is masked from 'package:magrittr':
##
## extract
library(dplyr)
##
## Attaching package: 'dplyr'
## The following objects are masked from 'package:stats':
##
## filter, lag
## The following objects are masked from 'package:base':
##
## intersect, setdiff, setequal, union
library(jpeg)
library(tree)
# a) carrega uma imagem jpeg no R
img <- readJPEG("C:/Users/Mitio/Desktop/Curso R/curso-r-2016/purple_wave.jpg")
# b) transforma o array da imagem em data.frame com infos de posicao (x,y) e cor (r,g,b)
# dimensões da imagem
img_dim <- dim(img)
# RGB para data.frame
img_df <- data.frame(
x = rep(1:img_dim[2], each = img_dim[1]),
y = rep(img_dim[1]:1, img_dim[2]),
r = as.vector(img[,,1]),
g = as.vector(img[,,2]),
b = as.vector(img[,,3])
) %>%
mutate(cor = rgb(r, g, b),
id = 1:n())
# para reprodução
set.seed(1)
# Parte 1) x, y, r, g
img_df_parte1 <- img_df %>%
sample_frac(3/5) %>% # separando 3/5 do banco
mutate(b_backup = b, # backup do azul original
b = 0, # retirando o azul da imagem
cor = rgb(r, g, b)) # cor da imagem sem o azul
# Parte 2) x, y, r, g, b
img_df_parte2 <- img_df %>% filter(!id%in%img_df_parte1$id) # filtra as linhas que estão na Parte 1
# Imagem sem o azul
sAzul <- ggplot(data = img_df_parte1, aes(x = x, y = y)) +
geom_point(colour = img_df_parte1$cor) +
labs(x = "x", y = "y", title = "Imagem sem B (azul)") +
coord_fixed(ratio = 1) +
theme_bw()
sAzul
# Apenas o azul da imagem
azul <- ggplot(data = img_df_parte2, aes(x = x, y = y)) +
geom_point(colour = img_df_parte2$cor) +
labs(x = "x", y = "y", title = "Apenas o B (azul)") +
coord_fixed(ratio = 1) +
theme_bw()
azul
img_dfa <- sample_n(img_df, 500, replace = F)
Matriz de correlação linear
img_dfa %>% select(x, y:b) %>%
cor %>%
round(2)
## x y r g b
## x 1.00 0.04 -0.02 -0.01 -0.02
## y 0.04 1.00 0.78 0.72 0.77
## r -0.02 0.78 1.00 0.98 1.00
## g -0.01 0.72 0.98 1.00 0.99
## b -0.02 0.77 1.00 0.99 1.00
Matriz de gráficos de dispersão
img_dfa %>% select(x, y:b) %>%
pairs()
Regressão. Fórmula proposta com base na análise: b = r + g + u, onde b, r e g são respectivamente as cores: azul, vermelho e verde da imagem, e u é o termo de erro.
lm1 <- lm(b ~ r + g, data = img_df_parte2)
summary(lm1)
##
## Call:
## lm(formula = b ~ r + g, data = img_df_parte2)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.040943 -0.003067 0.000223 0.002998 0.039914
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) -7.384e-04 6.453e-05 -11.44 <2e-16 ***
## r 8.051e-01 7.076e-04 1137.86 <2e-16 ***
## g 3.262e-01 1.195e-03 273.07 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.007144 on 28221 degrees of freedom
## Multiple R-squared: 0.9994, Adjusted R-squared: 0.9994
## F-statistic: 2.214e+07 on 2 and 28221 DF, p-value: < 2.2e-16
Árvore de decisão
arv1 <- tree(b ~ r + g, img_df_parte2)
summary(arv1)
##
## Regression tree:
## tree(formula = b ~ r + g, data = img_df_parte2)
## Variables actually used in tree construction:
## [1] "r"
## Number of terminal nodes: 4
## Residual mean deviance: 0.003141 = 88.65 / 28220
## Distribution of residuals:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -1.621e-01 -4.306e-02 7.556e-05 0.000e+00 4.153e-02 1.591e-01
plot(arv1)
text(arv1, pretty = 0)
predito_arv1p1 <- predict(arv1, img_df_parte1)
predito_lm1p1 <-predict(lm1, img_df_parte1)
predito_arv1p2 <- predict(arv1, img_df_parte2)
predito_lm1p2 <-predict(lm1, img_df_parte2)
img_df_parte2 <- img_df_parte2 %>%
mutate(predito_lm1p2,
predito_arv1p2,
erro_lm1 = (b - predito_lm1p2)^2,
erro_arv1 = (b - predito_arv1p2)^2)
Modelo linear
soma_erro_lm1 <- sum(img_df_parte2$erro_lm1)
soma_erro_lm1
## [1] 1.440141
Árvore de decisão
soma_erro_arv1 <- sum(img_df_parte2$erro_arv1)
soma_erro_arv1
## [1] 88.64532
Figura original
img_original1 <- img_df %>%
mutate(cor = rgb(r, g, b))
original1 <- ggplot(data = img_original1, aes(x = x, y = y)) +
geom_point(colour = img_original1$cor) +
labs(x = "x", y = "y", title = "Imagem original)") +
coord_fixed(ratio = 1) +
theme_bw()
original1
Imagem predita no modelo linear
img_df_parte1 <- img_df_parte1 %>%
mutate(predito_lm1p1,
predito_arv1p1)
img_df_parte1$predito_lm1p1[img_df_parte1$predito_lm1p1<0] <- 0
img_df_parte2$predito_lm1p2[img_df_parte2$predito_lm1p2<0] <- 0
img_predito1 <- img_df_parte1 %>%
mutate(b = predito_lm1p1,
cor = rgb(r, g, b))
predito1 <- ggplot(data = img_predito1, aes(x = x, y = y)) +
geom_point(colour = img_predito1$cor) +
labs(x = "x", y = "y", title = "Imagem predita 1") +
coord_fixed(ratio = 1) +
theme_bw()
predito1
Imagem predita com a árvore de decisão
img_predito2 <- img_df_parte1 %>%
mutate(b = predito_arv1p1,
cor = rgb(r, g, b))
predito2 <- ggplot(data = img_predito2, aes(x = x, y = y)) +
geom_point(colour = img_predito2$cor) +
labs(x = "x", y = "y", title = "Imagem predita 2") +
coord_fixed(ratio = 1) +
theme_bw()
predito2
Conclusão: Para este caso, a predição do modelo linear (predito 1) ficou melhor do que o modelo de árvore de decisão. Aparentemente, isto ocorre pelo fato de se tratar de variaveis continuas, onde o método da arvore de decisão não é tão eficiente.
# a) carrega uma imagem jpeg no R
img2 <- readJPEG("C:/Users/Mitio/Desktop/Curso R/curso-r-2016/xadrez_colorido.jpg")
# b) transforma o array da imagem em data.frame com infos de posicao (x,y) e cor (r,g,b)
# dimensões da imagem
img_dim2 <- dim(img2)
# RGB para data.frame
img_df2 <- data.frame(
x = rep(1:img_dim2[2], each = img_dim2[1]),
y = rep(img_dim2[1]:1, img_dim2[2]),
r = as.vector(img2[,,1]),
g = as.vector(img2[,,2]),
b = as.vector(img2[,,3])
) %>%
mutate(cor = rgb(r, g, b),
id = 1:n())
# para reprodução
set.seed(1)
# Parte 1) x, y, r, g
img_df_parte1_2 <- img_df2 %>%
sample_frac(3/5) %>% # separando 3/5 do banco
mutate(b_backup = b, # backup do azul original
b = 0, # retirando o azul da imagem
cor = rgb(r, g, b)) # cor da imagem sem o azul
# Parte 2) x, y, r, g, b
img_df_parte2_2 <- img_df2 %>% filter(!id%in%img_df_parte1_2$id) # filtra as linhas que estão na Parte 1
# Imagem sem o azul
sAzul2 <- ggplot(data = img_df_parte1_2, aes(x = x, y = y)) +
geom_point(colour = img_df_parte1_2$cor) +
labs(x = "x", y = "y", title = "Imagem sem B (azul)") +
coord_fixed(ratio = 1) +
theme_bw()
sAzul2
# Apenas o azul da imagem
azul2 <- ggplot(data = img_df_parte2_2, aes(x = x, y = y)) +
geom_point(colour = img_df_parte2_2$cor) +
labs(x = "x", y = "y", title = "Apenas o B (azul)") +
coord_fixed(ratio = 1) +
theme_bw()
azul2
img_dfa2 <- sample_n(img_df2, 500, replace = F)
Matriz de correlação linear
img_dfa2 %>%
select(x, y:b) %>%
cor %>%
round(2)
## x y r g b
## x 1.00 0.03 0.13 0.01 0.03
## y 0.03 1.00 -0.05 -0.03 0.00
## r 0.13 -0.05 1.00 0.44 0.16
## g 0.01 -0.03 0.44 1.00 -0.02
## b 0.03 0.00 0.16 -0.02 1.00
Matriz de gráficos de dispersão
img_dfa2 %>% select(x, y:b) %>%
pairs()
Regressão. Fórmula proposta com base na análise descritiva: b = r + g + u, onde b, r e g são respectivamente as cores: azul, vermelho e verde da imagem, e u é o termo de erro.
lm4 <- lm(b ~ r + g, data = img_df_parte2_2)
summary(lm4)
##
## Call:
## lm(formula = b ~ r + g, data = img_df_parte2_2)
##
## Residuals:
## Min 1Q Median 3Q Max
## -0.31355 -0.14422 -0.12579 -0.02177 0.93585
##
## Coefficients:
## Estimate Std. Error t value Pr(>|t|)
## (Intercept) 0.139419 0.004061 34.33 <2e-16 ***
## r 0.174746 0.007678 22.76 <2e-16 ***
## g -0.157319 0.009108 -17.27 <2e-16 ***
## ---
## Signif. codes: 0 '***' 0.001 '**' 0.01 '*' 0.05 '.' 0.1 ' ' 1
##
## Residual standard error: 0.3093 on 11589 degrees of freedom
## Multiple R-squared: 0.04688, Adjusted R-squared: 0.04671
## F-statistic: 285 on 2 and 11589 DF, p-value: < 2.2e-16
Árvore de decisão
arv2 <- tree(b ~ r + g, img_df_parte2_2)
summary(arv2)
##
## Regression tree:
## tree(formula = b ~ r + g, data = img_df_parte2_2)
## Number of terminal nodes: 10
## Residual mean deviance: 0.02367 = 274.1 / 11580
## Distribution of residuals:
## Min. 1st Qu. Median Mean 3rd Qu. Max.
## -0.92920 -0.03748 -0.02964 0.00000 0.01742 0.76900
plot(arv2)
text(arv2, pretty = 0)
predito_arv2p1 <- predict(arv2, img_df_parte1_2)
predito_lm4p1 <-predict(lm4, img_df_parte1_2)
predito_arv2p2 <- predict(arv2, img_df_parte2_2)
predito_lm4p2 <-predict(lm4, img_df_parte2_2)
img_df_parte2_2 <- img_df_parte2_2 %>%
mutate(predito_lm4p2,
predito_arv2p2,
erro_lm4 = (b - predito_lm4p2)^2,
erro_arv2 = (b - predito_arv2p2)^2)
Modelo linear
soma_erro_lm4 <- sum(img_df_parte2_2$erro_lm4)
soma_erro_lm4
## [1] 1108.977
Árvore de decisão
soma_erro_arv2 <- sum(img_df_parte2_2$erro_arv2)
soma_erro_arv2
## [1] 274.1356
Figura original
img_original2 <- img_df2 %>%
mutate(cor = rgb(r, g, b))
original2 <- ggplot(data = img_original2, aes(x = x, y = y)) +
geom_point(colour = img_original2$cor) +
labs(x = "x", y = "y", title = "Imagem original)") +
coord_fixed(ratio = 1) +
theme_bw()
original2
Imagem predita no modelo linear
img_df_parte1_2 <- img_df_parte1_2 %>%
mutate(predito_lm4p1,
predito_arv2p1)
img_df_parte1_2$predito_lm4p1[img_df_parte1_2$predito_lm4p1<0] <- 0
img_df_parte2_2$predito_lm4p2[img_df_parte2_2$predito_lm4p2<0] <- 0
img_predito3 <- img_df_parte1_2 %>%
mutate(b = predito_lm4p1,
cor = rgb(r, g, b))
predito3 <- ggplot(data = img_predito3, aes(x = x, y = y)) +
geom_point(colour = img_predito3$cor) +
labs(x = "x", y = "y", title = "Imagem predita 3") +
coord_fixed(ratio = 1) +
theme_bw()
predito3
Imagem predita com a árvore de decisão
img_predito4 <- img_df_parte1_2 %>%
mutate(b = predito_arv2p1,
cor = rgb(r, g, b))
predito4 <- ggplot(data = img_predito4, aes(x = x, y = y)) +
geom_point(colour = img_predito4$cor) +
labs(x = "x", y = "y", title = "Imagem predita 4") +
coord_fixed(ratio = 1) +
theme_bw()
predito4
Conclusão: Para este caso, a predição da cor azul peloo modelo de árvore de decisão (predito4) ficou melhor do que o modelo linear. Aparentemente, isto ocorre pelo fato de se tratar de variaveis discretas, onde cada pixel apresenta ausencia ou presença de determinada cor em um valor fixo.
link_tree <- 'https://janusaureus.files.wordpress.com/2012/05/checked_scrapbook_paper_by_polstars_stock.jpg'
link_tree
## [1] "https://janusaureus.files.wordpress.com/2012/05/checked_scrapbook_paper_by_polstars_stock.jpg"
link_lm<- 'http://lounge.obviousmag.org/sphere/2012/01/27/o-vilao-esqueleto-do-desenho-he-man-e-os-defensores-do-universo-1273175358804_300x300.jpg'
link_lm
## [1] "http://lounge.obviousmag.org/sphere/2012/01/27/o-vilao-esqueleto-do-desenho-he-man-e-os-defensores-do-universo-1273175358804_300x300.jpg"